home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops ƒ / zBase < prev    next >
Text File  |  1998-11-09  |  10KB  |  426 lines
  1. \ zBase
  2.  
  3. \ This file is the PPC equivalent of the 68k "Base" file.  It's a
  4. \ "z" file - it's not target compiled, but is loaded on the PPC itself.
  5. \ Some PPC defns have already been target compiled in pBase - here we
  6. \ include all the rest.
  7.  
  8. \ [ and ] have been left to here as problems arise if we try to define
  9. \  them in the target compilation.
  10.  
  11.  
  12. \        ================= MARKER-related words ==================
  13. \
  14. \ Before we do anything else, we need to resolve some forward definitions
  15. \  required by MARKER.  MARKER is in pBase since we need it to be already
  16. \  defined before we load this file, so that it gets a proper file mark.
  17.  
  18.  
  19. 0    value    cdp2use
  20.  
  21. : (mrk)
  22.     cdp2use
  23.     dup displace    -> CDP  4 +
  24.         displace    -> DP
  25.     CDP (forget)
  26.     -echo
  27. ;
  28.  
  29. :f marker_h  ( xt -- )
  30.     2 + -> cdp2use
  31.     ['] (mrk)  (comp)
  32. ;f
  33.  
  34. :f fmrk  ( addr -- )
  35.     -> cdp2use  (mrk)  ;f
  36.  
  37.  
  38. \        ==================================================
  39.  
  40. false    value    testing?
  41. false    value    torture?
  42. false    value    vtest?
  43.  
  44. : xx  db  ;
  45.  
  46. : [        (suspend_compilation)  0 -> state  ;        immediate
  47. : ]        (resume_compilation)  -1 -> state  ;        immediate
  48.  
  49.  
  50. \ Some inline defns:
  51.  
  52. : 1+    inline{ 1 +} ;
  53. : 2+    inline{ 2 +} ;
  54. : 3+    inline{ 3 +} ;
  55. : 4+    inline{ 4 +} ;
  56.  
  57. : 1-    inline{ 1 -} ;
  58. : 2-    inline{ 2 -} ;
  59. : 3-    inline{ 3 -} ;
  60. : 4-    inline{ 4 -} ;
  61.  
  62. : 2*    inline{ 1 <<}  ;
  63. : 2/    inline{ 1 a>>} ;
  64. : 4*    inline{ 2 <<}  ;
  65. : 4/    inline{ 2 a>>} ;
  66.  
  67. \ ANSI words
  68.  
  69. : CELL+        inline{ 4 +} ;
  70. : CELL-        inline{ 4 -} ;
  71. : CELLS        inline{ 2 <<} ;
  72. : CHAR+        inline{ 1 +} ;
  73. : CHARS        inline{ } ;
  74.  
  75. 4    constant    1CELL            \ Not ANSI, but useful
  76.  
  77.  
  78. \ (") is in qpCond.
  79.  
  80.  
  81. \    In the 68k version, :a ... ;a is used for action handlers, to set up the
  82. \    module base register if we're calling a word in a module.  On the PPC, our
  83. \    reloc addr format identifies the segment, so we can take care of everything
  84. \    in our x-addr and x-array classes.  So here we just define :a and ;a to be
  85. \    the same as : and ;.
  86.  
  87.  
  88. : :A    postpone :  ;            immediate
  89. : ;A    postpone ;  ;            immediate
  90.  
  91.  
  92. : "
  93.     state
  94.     IF        (")                        \ compiling
  95.     ELSE    34 parse                \ interpreting
  96.     THEN
  97. ;                immediate
  98.  
  99.  
  100. : S"    postpone "  ;        immediate        \ ANSI synonym for "
  101.  
  102.  
  103. : ."
  104.     state
  105.     IF        (")  postpone type        \ compiling
  106.     ELSE    34 parse  type            \ interpreting
  107.     THEN
  108. ;                    immediate
  109.  
  110. : ABORT"
  111.     postpone "
  112.     postpone do_abq  ;        immediate
  113.  
  114.  
  115. \ (* ... *) defines a multi-line comment, which can be very useful.  Many
  116. \ Pascal compilers use these symbols - I thought it better not to use
  117. \ the C-style /* ... */  since */ already has a meaning.
  118. \ A useful improvement to the typical Pascal implementation is to keep a
  119. \ level count so that this kind of comment can be nested.
  120.  
  121. : (*
  122.     1                            \ initial level count
  123.     BEGIN
  124.         Mword  count  2dup
  125.         " (*"  s=
  126.         IF    2drop  1 +            \ increment level count
  127.         ELSE
  128.             " *)"  s=
  129.             IF  1 -                \ decrement level count
  130.                 ?dup  0EXIT        \ and if zero, we're done
  131.             THEN
  132.         THEN
  133.     AGAIN  ;        immediate
  134.  
  135.  
  136. variable NULLOSSTR
  137. 0  nullOSstr !
  138.  
  139.  
  140. : @WORD        \ ( -- addr )  Gets next blank-delimited word from input stream,
  141.             \  with no case conversion.
  142.     bl word  ;
  143.  
  144. : LIT        \ ( n -- )  A state-smart version of LITERAL.  Corresponds
  145.             \ to LITERAL in Fig-Forth or original Neon, whereas our
  146.             \ present LITERAL is ANSI.
  147.  
  148.     state  IF  postpone literal  THEN  ;        immediate
  149.  
  150. : 0,  0 ,  ;        \ Compiles an empty cell
  151.  
  152. : @VAL    intrp1  ;    \ Compiles a number from input stream
  153.  
  154.  
  155. : 'TYPE        \ ( -- 4bytes )   OS type literal
  156.     pad 4 bl fill  @word count 4 min
  157.     pad swap cmove  pad @  postpone lit  ;        immediate
  158.  
  159.  
  160. (*    RECURSE calls the current definition.  We need all the flag bytes
  161.     in place, so the regs get set up properly.  The second flag byte
  162.     is OK already, but we still need to set the first one, with the
  163.     #cells in regs on return.  So we now decide this if we
  164.     haven't already, put the flag byte there, then compile the call.
  165.     Note that recursive words must be non-leaf, since the LR has to be
  166.     saved.  This is looked after by (comp), and in any case the leaf
  167.     bit is the top bit in the flag byte we have to store, and we leave
  168.     it zero.
  169. *)
  170.  
  171.  
  172. : RECURSE
  173.     get_rtn_cnts drop
  174.     curr-def 2-  c!
  175.     curr-def 2-  (comp)
  176. ;            immediate
  177.  
  178.  
  179. : CHAR        @word 1+ c@  ;
  180. : [CHAR]    @word 1+ c@  postpone literal  ;    immediate
  181.  
  182. : &            \ ( -- c )  A shorter state-smart version.
  183.     @word 1+ c@
  184.     postpone lit  ;            immediate
  185.  
  186.  
  187. : $            \ State-smart HEX literal word
  188.     base >r
  189.     hex  Mword  number  postpone lit
  190.     r> -> base  ;            immediate
  191.  
  192. \ Str255 stuff already defined, in setup and pBase.
  193.  
  194. \ Resource support is in pBase.
  195.  
  196. \ ================= Messages and errors ==================
  197.  
  198. : ?ERROR        \ ( b -- )  Aborts and prints resource string if true.
  199.                 \ Usage:  ?error 999
  200.     postpone if
  201.     intrp1  ( get err# )  postpone literal  postpone die
  202.     postpone then  ;        immediate
  203.  
  204.  
  205. \ this is now in pBase:
  206. \ : (TSTR)            \ ( id# -- )  Prints string with given resID.
  207. \    getString type  ;
  208.  
  209. : TYPE#        \ Prints string for id# in stream
  210.     intrp1  postpone lit   postpone tStr  ;        immediate
  211.  
  212.  
  213. : .RSTR    \ ( -- )  print "Msg# ..." then string with given resID
  214.     ." Msg# " dup . ." : "  tStr  ;
  215.  
  216. : MSG#        \  usage: " Msg# <number>"
  217.     intrp1  postpone lit  postpone .rStr  ;        immediate
  218.  
  219.  
  220. \ ====================================
  221.  
  222. : RDEPTH        rp0  rp@ - 4/ 2-  ;
  223.  
  224. : ?RDEPTH        rp@  sp0 20 + < ?error 116  ;    \ err if rtn stk about to
  225.                                                 \ collide with data stk
  226.  
  227. \        ========== Type checking ===========
  228.  
  229. \ Sometimes we want to check that a non-object parameter to a word is of a 
  230. \ certain type.  We give it a unique type code and use TYPCHK.
  231.  
  232. : TYPCHK    <>  ?error 179  ;
  233.  
  234.  
  235. \        ====================================
  236.  
  237.  
  238. \ Commonly needed error words.  These are forward defined - the main
  239. \ application should provide a sensible definition, with a nice friendly
  240. \ alert box, to tell the user in a nice friendly way that things are up
  241. \ the creek.
  242.  
  243. forward    NOMEM        \ Call when (not if!) we run out of memory.
  244.  
  245. (*  moved to qpClass...
  246. forward    I/O_ERR        \ ( err# -- )  Call when there's an I/O error.
  247.  
  248. : OK?        \ ( rc -- )  A useful word to use after an I/O op.
  249.     ?dup  0EXIT  I/O_err  ;
  250. *)
  251.  
  252.  
  253. \     ======== Various utility words needed later =========
  254.  
  255.  
  256. \ BECOME allows restarting at a given word, with all stacks
  257. \ empty.  This is necessary in menu handlers and other areas
  258. \ that could create indefinite nesting situations.
  259.  
  260. ' quit    vect    becomeXT
  261.  
  262. : BE    sp0 sp!  rp0 rp!  becomeXT  quit  ;
  263.  
  264. : (BE)    -> becomeXT be  ;
  265.  
  266.  
  267. : BECOME        \ Usage: Become newWord - compiles code to Be at runtime
  268.     state
  269.     IF        postpone [']  postpone (be)
  270.     ELSE    '  -> becomeXT  be
  271.     THEN  ;            immediate
  272.  
  273.  
  274. : DATETIME
  275.     $ 20C  @  ;
  276.  
  277.  
  278. \        ============ Tables, lists etc. ===============
  279.  
  280. (*    From Mops 2.5 on, we're trying to be consistent with the way we delimit
  281.     various kinds of lists with { ... }.  No, we're not trying to copy C,
  282.     but let's at least follow the "principle of minimum astonishment".
  283.     Thus, with words like xts{, we'll allow a variant "xts {" where you
  284.     can put a space before the "{".  This is very easy to implement, so
  285.     why not?
  286. *)
  287.  
  288. forward  {        immediate
  289.  
  290. : GOBBLE{        \ gobbles a "{" which must follow as a separate word.
  291.     '  ['] {  <>  ?error 113  ;        \ "{" expected
  292.  
  293. : )        123 die  ;    immediate        \ ") read when no list is current"
  294. : (})    123 die  ;    immediate        \ "unmatched }"
  295.  
  296. ' (})    vect    }    immediate        \ } will mean different things in different
  297.                                     \  contexts.
  298.  
  299. : }OR)?        \ ( cfa -- cfa b )
  300.     dup  ['] }  =  over  ['] ) =  or  ;
  301.  
  302.  
  303. : XTS{            \ State-smart word to compile or stack a list
  304.                 \ of xts.  Pulls words from stream, until "}".
  305.     0
  306.     BEGIN   '   }or)?
  307.     NWHILE    state    IF        \ const_data_ref  reloc>const_data  postpone @abs
  308.                             lit_addr
  309.                     ELSE    swap 
  310.                     THEN  1+
  311.     REPEAT
  312.     drop   state IF  postpone literal  THEN  ;        immediate
  313.  
  314. : CFAS{    postpone xts{  ;    immediate        \ Synonyms for compatibility
  315. : CFAS(    postpone xts{  ;    immediate
  316.  
  317. : XTS    gobble{  postpone xts{  ;        immediate
  318.  
  319.  
  320. (* SCON defines a string constant.  Usage:
  321.  
  322.     scon    <name>    "a string"
  323.  
  324.   Runtime: ( -- addr len )
  325.  
  326.   Change from Neon: the first nonblank char after the name of the SCON
  327.   becomes the delimiter.  So " can be used as usual, but anything else can
  328.   be used instead, e.g.:
  329.  
  330.      scon    <name>    /this string contains " as non-delimiter/
  331. *)
  332.  
  333. : SCON
  334.     <BUILDS        bl skip-src+
  335.                 src-start >in @ + c@  ,dlm-str
  336.     DOES>        count  ;
  337.  
  338.  
  339. \ note: INSTEAD is defined in zArgs since it needs locals.
  340.  
  341.  
  342. \ CASE should be used for non-contiguous or dynamically computed values.
  343. \ This is a modified Eaker/Duncan model.
  344. \ Our optimization strategy gives quite good code.
  345.  
  346. : CASE        ?comp  302  ;        immediate
  347.  
  348. : OF
  349.     postpone over  postpone =  postpone if
  350.     postpone drop  ;            immediate
  351.  
  352. : RANGEOF
  353.     postpone within?  postpone if
  354.     postpone drop  ;            immediate
  355.  
  356. : ENDOF
  357.     postpone else  ;            immediate
  358.  
  359. : ENDCASE
  360.     postpone drop
  361.     BEGIN  dup 302 =  NWHILE  >resolve&equalize   REPEAT  drop  ;
  362. immediate
  363.  
  364. (* TYPE{ and ENUM{ (synonyms) define a Pascal/C-like enumerated type.
  365.    At this stage we don't give a name to the "type" as such, as we can't
  366.    do anything really sensible with it.  However later we can optionally
  367.    load the ENUM-TYPE class which is rather more Pascal-like.  But even
  368.    without that, the enumeration is very useful by itself.
  369. *)
  370.  
  371.     0    value    TYPECNT
  372.  
  373. ' null    vect    DO_ET        \ Hook for handling the ENUM-TYPE
  374.                             \ class when it's loaded
  375.  
  376. : ENDLIST?        \ ( chr -- b )
  377.     #lines_read >r
  378.     >in @  >r
  379.     Mword  count 1 =  down c@ =  and
  380.     IF        r> drop    r> drop  true        \ finished - leave delimiter skipped
  381.     ELSE    r>  >in !                    \ another list item - reread it
  382.             r> #lines_read <>
  383.             IF  0 >in !  THEN
  384.             false            
  385.     THEN  ;
  386.  
  387.  
  388. : ENUM{
  389.     0 -> typeCnt                \ 1st value
  390.     BEGIN    typeCnt  constant  1 ++> typeCnt
  391.             & }  endlist?
  392.     UNTIL
  393.     do_ET  ;
  394.  
  395. : TYPE{        enum{  ;            \ C fans might like this name better
  396.  
  397. : ENUM        gobble{  enum{  ;
  398.  
  399.                 \ note we can't allow "type { ..." since "type" has another
  400.                 \ meaning already.  But "enum { ..."  is OK.
  401.  
  402. enum{ InMainDic DataInMainDic InOtherMod DataInOtherMod InThisMod }
  403.                             \ Relocatable addr types
  404.  
  405.  
  406. \        ========== Error diagnostics ===========
  407.  
  408. \ We use special values for nil handles and nil pointers.  These are
  409. \ odd high addresses, so hopefully we'll trap if we try to use them.
  410.  
  411. : .RTN            \ ( addr -- )
  412.     cr ." From  $"
  413.     .h  4 spaces
  414. ;
  415.  
  416.  
  417. : RANGE_ERR        \ ( index range rtn-addr -- )
  418.     dup 1+ 0=  ?error 128            \ Spurious range error
  419.     .rtn
  420.     dup -1 <
  421.     IF        nip  ?error 130            \ Not an indexed class
  422.     ELSE    ." Range: " .  ."   Index: " .
  423.             true  ?error 129
  424.     THEN  ;
  425.  
  426.